home *** CD-ROM | disk | FTP | other *** search
/ FishMarket 1.0 / FishMarket v1.0.iso / fishies / 001-025 / disk_003 / xlisp / xlobj.c < prev    next >
C/C++ Source or Header  |  1992-05-06  |  16KB  |  691 lines
  1. /* xlobj - xlisp object functions */
  2.  
  3. #include "xlisp.h"
  4.  
  5. #ifdef MEGAMAX
  6. overlay "overflow"
  7. #endif
  8.  
  9. /* external variables */
  10. extern NODE *xlstack;
  11. extern NODE *xlenv,*xlnewenv;
  12. extern NODE *s_stdout;
  13. extern NODE *self;
  14. extern NODE *class;
  15. extern NODE *object;
  16. extern NODE *new;
  17. extern NODE *isnew;
  18. extern NODE *msgcls;
  19. extern NODE *msgclass;
  20. extern int varcnt;
  21.  
  22. /* instance variable numbers for the class 'Class' */
  23. #define MESSAGES    0    /* list of messages */
  24. #define IVARS        1    /* list of instance variable names */
  25. #define CVARS        2    /* list of class variable names */
  26. #define CVALS        3    /* list of class variable values */
  27. #define SUPERCLASS    4    /* pointer to the superclass */
  28. #define IVARCNT        5    /* number of class instance variables */
  29. #define IVARTOTAL    6    /* total number of instance variables */
  30.  
  31. /* number of instance variables for the class 'Class' */
  32. #define CLASSSIZE    7
  33.  
  34. /* forward declarations */
  35. FORWARD NODE *xlgetivar();
  36. FORWARD NODE *xlsetivar();
  37. FORWARD NODE *xlivar();
  38. FORWARD NODE *xlcvar();
  39. FORWARD NODE *findmsg();
  40. FORWARD NODE *findvar();
  41. FORWARD NODE *defvars();
  42. FORWARD NODE *makelist();
  43.  
  44. /* xlclass - define a class */
  45. NODE *xlclass(name,vcnt)
  46.   char *name; int vcnt;
  47. {
  48.     NODE *sym,*cls;
  49.  
  50.     /* create the class */
  51.     sym = xlsenter(name);
  52.     cls = sym->n_symvalue = newnode(OBJ);
  53.     cls->n_obclass = class;
  54.     cls->n_obdata = makelist(CLASSSIZE);
  55.  
  56.     /* set the instance variable counts */
  57.     if (vcnt > 0) {
  58.     xlsetivar(cls,IVARCNT,newnode(INT))->n_int = vcnt;
  59.     xlsetivar(cls,IVARTOTAL,newnode(INT))->n_int = vcnt;
  60.     }
  61.  
  62.     /* set the superclass to 'Object' */
  63.     xlsetivar(cls,SUPERCLASS,object);
  64.  
  65.     /* return the new class */
  66.     return (cls);
  67. }
  68.  
  69. /* xlmfind - find the message binding for a message to an object */
  70. NODE *xlmfind(obj,msym)
  71.   NODE *obj,*msym;
  72. {
  73.     return (findmsg(obj->n_obclass,msym));
  74. }
  75.  
  76. /* xlxsend - send a message to an object */
  77. NODE *xlxsend(obj,msg,args)
  78.   NODE *obj,*msg,*args;
  79. {
  80.     NODE *oldstk,*oldenv,*oldnewenv,method,cptr,eargs,val,*isnewmsg;
  81.  
  82.     /* save the old environment */
  83.     oldnewenv = xlnewenv; oldenv = xlnewenv = xlenv;
  84.  
  85.     /* create a new stack frame */
  86.     oldstk = xlsave(&method,&cptr,&eargs,&val,NULL);
  87.  
  88.     /* get the method for this message */
  89.     method.n_ptr = cdr(msg);
  90.  
  91.     /* make sure its a function or a subr */
  92.     if (!subrp(method.n_ptr) && !consp(method.n_ptr))
  93.     xlfail("bad method");
  94.  
  95.     /* bind the symbols 'self' and 'msgclass' */
  96.     xlbind(self,obj);
  97.     xlbind(msgclass,msgcls);
  98.  
  99.     /* evaluate the function call */
  100.     eargs.n_ptr = xlevlist(args);
  101.     if (subrp(method.n_ptr)) {
  102.     xlfixbindings();
  103.     val.n_ptr = (*method.n_ptr->n_subr)(eargs.n_ptr);
  104.     }
  105.     else {
  106.  
  107.     /* bind the formal arguments */
  108.     xlabind(car(method.n_ptr),eargs.n_ptr);
  109.     xlfixbindings();
  110.  
  111.     /* execute the code */
  112.     cptr.n_ptr = cdr(method.n_ptr);
  113.     while (cptr.n_ptr != NIL)
  114.         val.n_ptr = xlevarg(&cptr.n_ptr);
  115.     }
  116.  
  117.     /* restore the environment */
  118.     xlunbind(oldenv); xlnewenv = oldnewenv;
  119.  
  120.     /* after creating an object, send it the "isnew" message */
  121.     if (car(msg) == new && val.n_ptr != NIL) {
  122.     if ((isnewmsg = xlmfind(val.n_ptr,isnew)) == NIL)
  123.         xlfail("no method for the isnew message");
  124.     val.n_ptr = xlxsend(val.n_ptr,isnewmsg,args);
  125.     }
  126.  
  127.     /* restore the previous stack frame */
  128.     xlstack = oldstk;
  129.  
  130.     /* return the result value */
  131.     return (val.n_ptr);
  132. }
  133.  
  134. /* xlsend - send a message to an object (message in arg list) */
  135. NODE *xlsend(obj,args)
  136.   NODE *obj,*args;
  137. {
  138.     NODE *msg;
  139.  
  140.     /* find the message binding for this message */
  141.     if ((msg = xlmfind(obj,xlevmatch(SYM,&args))) == NIL)
  142.     xlfail("no method for this message");
  143.  
  144.     /* send the message */
  145.     return (xlxsend(obj,msg,args));
  146. }
  147.  
  148. /* xlobsym - find a class or instance variable for the current object */
  149. NODE *xlobsym(sym)
  150.   NODE *sym;
  151. {
  152.     NODE *obj;
  153.  
  154.     if ((obj = self->n_symvalue) != NIL && objectp(obj))
  155.     return (findvar(obj,sym));
  156.     else
  157.     return (NIL);
  158. }
  159.  
  160. /* mnew - create a new object instance */
  161. LOCAL NODE *mnew()
  162. {
  163.     NODE *oldstk,obj,*cls;
  164.  
  165.     /* create a new stack frame */
  166.     oldstk = xlsave(&obj,NULL);
  167.  
  168.     /* get the class */
  169.     cls = self->n_symvalue;
  170.  
  171.     /* generate a new object */
  172.     obj.n_ptr = newnode(OBJ);
  173.     obj.n_ptr->n_obclass = cls;
  174.     obj.n_ptr->n_obdata = makelist(getivcnt(cls,IVARTOTAL));
  175.  
  176.     /* restore the previous stack frame */
  177.     xlstack = oldstk;
  178.  
  179.     /* return the new object */
  180.     return (obj.n_ptr);
  181. }
  182.  
  183. /* misnew - initialize a new class */
  184. LOCAL NODE *misnew(args)
  185.   NODE *args;
  186. {
  187.     NODE *oldstk,super,*obj;
  188.  
  189.     /* create a new stack frame */
  190.     oldstk = xlsave(&super,NULL);
  191.  
  192.     /* get the superclass if there is one */
  193.     if (args != NIL)
  194.     super.n_ptr = xlmatch(OBJ,&args);
  195.     else
  196.     super.n_ptr = object;
  197.     xllastarg(args);
  198.  
  199.     /* get the object */
  200.     obj = self->n_symvalue;
  201.  
  202.     /* store the superclass */
  203.     xlsetivar(obj,SUPERCLASS,super.n_ptr);
  204.     xlsetivar(obj,IVARTOTAL,newnode(INT))->n_int =
  205.         getivcnt(super.n_ptr,IVARTOTAL);
  206.  
  207.     /* restore the previous stack frame */
  208.     xlstack = oldstk;
  209.  
  210.     /* return the new object */
  211.     return (obj);
  212. }
  213.  
  214. /* xladdivar - enter an instance variable */
  215. xladdivar(cls,var)
  216.   NODE *cls; char *var;
  217. {
  218.     NODE *ivar,*lptr;
  219.  
  220.     /* find the 'ivars' instance variable */
  221.     ivar = xlivar(cls,IVARS);
  222.  
  223.     /* add the instance variable */
  224.     lptr = newnode(LIST);
  225.     rplacd(lptr,car(ivar));
  226.     rplaca(ivar,lptr);
  227.     rplaca(lptr,xlsenter(var));
  228. }
  229.  
  230. /* entermsg - add a message to a class */
  231. LOCAL NODE *entermsg(cls,msg)
  232.   NODE *cls,*msg;
  233. {
  234.     NODE *ivar,*lptr,*mptr;
  235.  
  236.     /* find the 'messages' instance variable */
  237.     ivar = xlivar(cls,MESSAGES);
  238.  
  239.     /* lookup the message */
  240.     for (lptr = car(ivar); lptr != NIL; lptr = cdr(lptr))
  241.     if (car(mptr = car(lptr)) == msg)
  242.         return (mptr);
  243.  
  244.     /* allocate a new message entry if one wasn't found */
  245.     lptr = newnode(LIST);
  246.     rplacd(lptr,car(ivar));
  247.     rplaca(ivar,lptr);
  248.     rplaca(lptr,mptr = newnode(LIST));
  249.     rplaca(mptr,msg);
  250.  
  251.     /* return the symbol node */
  252.     return (mptr);
  253. }
  254.  
  255. /* answer - define a method for answering a message */
  256. LOCAL NODE *answer(args)
  257.   NODE *args;
  258. {
  259.     NODE *oldstk,arg,msg,fargs,code;
  260.     NODE *obj,*mptr,*fptr;
  261.  
  262.     /* create a new stack frame */
  263.     oldstk = xlsave(&arg,&msg,&fargs,&code,NULL);
  264.  
  265.     /* initialize */
  266.     arg.n_ptr = args;
  267.  
  268.     /* message symbol, formal argument list and code */
  269.     msg.n_ptr = xlmatch(SYM,&arg.n_ptr);
  270.     fargs.n_ptr = xlmatch(LIST,&arg.n_ptr);
  271.     code.n_ptr = xlmatch(LIST,&arg.n_ptr);
  272.     xllastarg(arg.n_ptr);
  273.  
  274.     /* get the object node */
  275.     obj = self->n_symvalue;
  276.  
  277.     /* make a new message list entry */
  278.     mptr = entermsg(obj,msg.n_ptr);
  279.  
  280.     /* setup the message node */
  281.     rplacd(mptr,fptr = newnode(LIST));
  282.     rplaca(fptr,fargs.n_ptr);
  283.     rplacd(fptr,code.n_ptr);
  284.  
  285.     /* restore the previous stack frame */
  286.     xlstack = oldstk;
  287.  
  288.     /* return the object */
  289.     return (obj);
  290. }
  291.  
  292. /* mivars - define the list of instance variables */
  293. LOCAL NODE *mivars(args)
  294.   NODE *args;
  295. {
  296.     NODE *cls,*super;
  297.     int scnt;
  298.  
  299.     /* define the list of instance variables */
  300.     cls = defvars(args,IVARS);
  301.  
  302.     /* get the superclass instance variable count */
  303.     if ((super = xlgetivar(cls,SUPERCLASS)) != NIL)
  304.     scnt = getivcnt(super,IVARTOTAL);
  305.     else
  306.     scnt = 0;
  307.  
  308.     /* save the number of instance variables */
  309.     xlsetivar(cls,IVARCNT,newnode(INT))->n_int = varcnt;
  310.     xlsetivar(cls,IVARTOTAL,newnode(INT))->n_int = scnt+varcnt;
  311.  
  312.     /* return the class */
  313.     return (cls);
  314. }
  315.  
  316. /* getivcnt - get the number of instance variables for a class */
  317. LOCAL int getivcnt(cls,ivar)
  318.   NODE *cls; int ivar;
  319. {
  320.     NODE *cnt;
  321.  
  322.     if ((cnt = xlgetivar(cls,ivar)) != NIL)
  323.     if (fixp(cnt))
  324.         return (cnt->n_int);
  325.     else
  326.         xlfail("bad value for instance variable count");
  327.     else
  328.     return (0);
  329. }
  330.  
  331. /* mcvars - define the list of class variables */
  332. LOCAL NODE *mcvars(args)
  333.   NODE *args;
  334. {
  335.     NODE *cls;
  336.  
  337.     /* define the list of class variables */
  338.     cls = defvars(args,CVARS);
  339.  
  340.     /* make a new list of values */
  341.     xlsetivar(cls,CVALS,makelist(varcnt));
  342.  
  343.     /* return the class */
  344.     return (cls);
  345. }
  346.  
  347. /* defvars - define a class or instance variable list */
  348. LOCAL NODE *defvars(args,varnum)
  349.   NODE *args; int varnum;
  350. {
  351.     NODE *oldstk,vars,*vptr,*cls,*sym;
  352.  
  353.     /* create a new stack frame */
  354.     oldstk = xlsave(&vars,NULL);
  355.  
  356.     /* get ivar list */
  357.     vars.n_ptr = xlmatch(LIST,&args);
  358.     xllastarg(args);
  359.  
  360.     /* get the class node */
  361.     cls = self->n_symvalue;
  362.  
  363.     /* check each variable in the list */
  364.     varcnt = 0;
  365.     for (vptr = vars.n_ptr;
  366.      consp(vptr);
  367.      vptr = cdr(vptr)) {
  368.  
  369.     /* make sure this is a valid symbol in the list */
  370.     if ((sym = car(vptr)) == NIL || !symbolp(sym))
  371.         xlfail("bad variable list");
  372.  
  373.     /* make sure its not already defined */
  374.     if (checkvar(cls,sym))
  375.         xlfail("multiply defined variable");
  376.  
  377.     /* count the variable */
  378.     varcnt++;
  379.     }
  380.  
  381.     /* make sure the list ended properly */
  382.     if (vptr != NIL)
  383.     xlfail("bad variable list");
  384.  
  385.     /* define the new variable list */
  386.     xlsetivar(cls,varnum,vars.n_ptr);
  387.  
  388.     /* restore the previous stack frame */
  389.     xlstack = oldstk;
  390.  
  391.     /* return the class */
  392.     return (cls);
  393. }
  394.  
  395. /* xladdmsg - add a message to a class */
  396. xladdmsg(cls,msg,code)
  397.   NODE *cls; char *msg; NODE *(*code)();
  398. {
  399.     NODE *mptr;
  400.  
  401.     /* enter the message selector */
  402.     mptr = entermsg(cls,xlsenter(msg));
  403.  
  404.     /* store the method for this message */
  405.     rplacd(mptr,newnode(SUBR));
  406.     cdr(mptr)->n_subr = code;
  407. }
  408.  
  409. /* getclass - get the class of an object */
  410. LOCAL NODE *getclass(args)
  411.   NODE *args;
  412. {
  413.     /* make sure there aren't any arguments */
  414.     xllastarg(args);
  415.  
  416.     /* return the object's class */
  417.     return (self->n_symvalue->n_obclass);
  418. }
  419.  
  420. /* obshow - show the instance variables of an object */
  421. LOCAL NODE *obshow(args)
  422.   NODE *args;
  423. {
  424.     NODE *fptr;
  425.  
  426.     /* get the file pointer */
  427.     fptr = (args ? xlmatch(FPTR,&args) : s_stdout->n_symvalue);
  428.     xllastarg(args);
  429.  
  430.     /* print the object's instance variables */
  431.     xlprint(fptr,self->n_symvalue->n_obdata,TRUE);
  432.     xlterpri(fptr);
  433.  
  434.     /* return the object */
  435.     return (self->n_symvalue);
  436. }
  437.  
  438. /* defisnew - default 'isnew' method */
  439. LOCAL NODE *defisnew(args)
  440.   NODE *args;
  441. {
  442.     /* make sure there aren't any arguments */
  443.     xllastarg(args);
  444.  
  445.     /* return the object */
  446.     return (self->n_symvalue);
  447. }
  448.  
  449. /* sendsuper - send a message to an object's superclass */
  450. LOCAL NODE *sendsuper(args)
  451.   NODE *args;
  452. {
  453.     NODE *obj,*super,*msg;
  454.  
  455.     /* get the object */
  456.     obj = self->n_symvalue;
  457.  
  458.     /* get the object's superclass */
  459.     super = xlgetivar(obj->n_obclass,SUPERCLASS);
  460.  
  461.     /* find the message binding for this message */
  462.     if ((msg = findmsg(super,xlmatch(SYM,&args))) == NIL)
  463.     xlfail("no method for this message");
  464.  
  465.     /* send the message */
  466.     return (xlxsend(obj,msg,args));
  467. }
  468.  
  469. /* findmsg - find the message binding given an object and a class */
  470. LOCAL NODE *findmsg(cls,sym)
  471.   NODE *cls,*sym;
  472. {
  473.     NODE *lptr,*msg;
  474.  
  475.     /* start at the specified class */
  476.     msgcls = cls;
  477.  
  478.     /* look for the message in the class or superclasses */
  479.     while (msgcls != NIL) {
  480.  
  481.     /* lookup the message in this class */
  482.     for (lptr = xlgetivar(msgcls,MESSAGES);
  483.          lptr != NIL;
  484.          lptr = cdr(lptr))
  485.         if ((msg = car(lptr)) != NIL && car(msg) == sym)
  486.         return (msg);
  487.  
  488.     /* look in class's superclass */
  489.     msgcls = xlgetivar(msgcls,SUPERCLASS);
  490.     }
  491.  
  492.     /* message not found */
  493.     return (NIL);
  494. }
  495.  
  496. /* findvar - find a class or instance variable */
  497. LOCAL NODE *findvar(obj,sym)
  498.   NODE *obj,*sym;
  499. {
  500.     NODE *cls,*lptr;
  501.     int base,varnum;
  502.     int found;
  503.  
  504.     /* get the class of the object */
  505.     cls = obj->n_obclass;
  506.  
  507.     /* get the total number of instance variables */
  508.     base = getivcnt(cls,IVARTOTAL);
  509.  
  510.     /* find the variable */
  511.     found = FALSE;
  512.     for (; cls != NIL; cls = xlgetivar(cls,SUPERCLASS)) {
  513.  
  514.     /* get the number of instance variables for this class */
  515.     if ((base -= getivcnt(cls,IVARCNT)) < 0)
  516.         xlfail("error finding instance variable");
  517.  
  518.     /* check for finding the class of the current message */
  519.     if (!found && cls == msgclass->n_symvalue)
  520.         found = TRUE;
  521.  
  522.     /* lookup the instance variable */
  523.     varnum = 0;
  524.     for (lptr = xlgetivar(cls,IVARS);
  525.              lptr != NIL;
  526.              lptr = cdr(lptr))
  527.         if (found && car(lptr) == sym)
  528.         return (xlivar(obj,base + varnum));
  529.         else
  530.         varnum++;
  531.  
  532.     /* skip the class variables if the message class hasn't been found */
  533.     if (!found)
  534.         continue;
  535.  
  536.     /* lookup the class variable */
  537.     varnum = 0;
  538.     for (lptr = xlgetivar(cls,CVARS);
  539.              lptr != NIL;
  540.              lptr = cdr(lptr))
  541.         if (car(lptr) == sym)
  542.         return (xlcvar(cls,varnum));
  543.         else
  544.         varnum++;
  545.     }
  546.  
  547.     /* variable not found */
  548.     return (NIL);
  549. }
  550.  
  551. /* checkvar - check for an existing class or instance variable */
  552. LOCAL int checkvar(cls,sym)
  553.   NODE *cls,*sym;
  554. {
  555.     NODE *lptr;
  556.  
  557.     /* find the variable */
  558.     for (; cls != NIL; cls = xlgetivar(cls,SUPERCLASS)) {
  559.  
  560.     /* lookup the instance variable */
  561.     for (lptr = xlgetivar(cls,IVARS);
  562.              lptr != NIL;
  563.              lptr = cdr(lptr))
  564.         if (car(lptr) == sym)
  565.         return (TRUE);
  566.  
  567.     /* lookup the class variable */
  568.     for (lptr = xlgetivar(cls,CVARS);
  569.              lptr != NIL;
  570.              lptr = cdr(lptr))
  571.         if (car(lptr) == sym)
  572.         return (TRUE);
  573.     }
  574.  
  575.     /* variable not found */
  576.     return (FALSE);
  577. }
  578.  
  579. /* xlgetivar - get the value of an instance variable */
  580. NODE *xlgetivar(obj,num)
  581.   NODE *obj; int num;
  582. {
  583.     return (car(xlivar(obj,num)));
  584. }
  585.  
  586. /* xlsetivar - set the value of an instance variable */
  587. NODE *xlsetivar(obj,num,val)
  588.   NODE *obj; int num; NODE *val;
  589. {
  590.     rplaca(xlivar(obj,num),val);
  591.     return (val);
  592. }
  593.  
  594. /* xlivar - get an instance variable */
  595. NODE *xlivar(obj,num)
  596.   NODE *obj; int num;
  597. {
  598.     NODE *ivar;
  599.  
  600.     /* get the instance variable */
  601.     for (ivar = obj->n_obdata; num > 0; num--)
  602.     if (ivar != NIL)
  603.         ivar = cdr(ivar);
  604.     else
  605.         xlfail("bad instance variable list");
  606.  
  607.     /* return the instance variable */
  608.     return (ivar);
  609. }
  610.  
  611. /* xlcvar - get a class variable */
  612. NODE *xlcvar(cls,num)
  613.   NODE *cls; int num;
  614. {
  615.     NODE *cvar;
  616.  
  617.     /* get the class variable */
  618.     for (cvar = xlgetivar(cls,CVALS); num > 0; num--)
  619.     if (cvar != NIL)
  620.         cvar = cdr(cvar);
  621.     else
  622.         xlfail("bad class variable list");
  623.  
  624.     /* return the class variable */
  625.     return (cvar);
  626. }
  627.  
  628. /* makelist - make a list of nodes */
  629. LOCAL NODE *makelist(cnt)
  630.   int cnt;
  631. {
  632.     NODE *oldstk,list,*lnew;
  633.  
  634.     /* create a new stack frame */
  635.     oldstk = xlsave(&list,NULL);
  636.  
  637.     /* make the list */
  638.     for (; cnt > 0; cnt--) {
  639.     lnew = newnode(LIST);
  640.     rplacd(lnew,list.n_ptr);
  641.     list.n_ptr = lnew;
  642.     }
  643.  
  644.     /* restore the previous stack frame */
  645.     xlstack = oldstk;
  646.  
  647.     /* return the list */
  648.     return (list.n_ptr);
  649. }
  650.  
  651. /* xloinit - object function initialization routine */
  652. xloinit()
  653. {
  654.     /* don't confuse the garbage collector */
  655.     class = object = NIL;
  656.  
  657.     /* enter the object related symbols */
  658.     new        = xlsenter("new");
  659.     isnew    = xlsenter("isnew");
  660.     self    = xlsenter("self");
  661.     msgclass    = xlsenter("msgclass");
  662.  
  663.     /* create the 'Class' object */
  664.     class = xlclass("Class",CLASSSIZE);
  665.     class->n_obclass = class;
  666.  
  667.     /* create the 'Object' object */
  668.     object = xlclass("Object",0);
  669.  
  670.     /* finish initializing 'class' */
  671.     xlsetivar(class,SUPERCLASS,object);
  672.     xladdivar(class,"ivartotal");    /* ivar number 6 */
  673.     xladdivar(class,"ivarcnt");        /* ivar number 5 */
  674.     xladdivar(class,"superclass");    /* ivar number 4 */
  675.     xladdivar(class,"cvals");        /* ivar number 3 */
  676.     xladdivar(class,"cvars");        /* ivar number 2 */
  677.     xladdivar(class,"ivars");        /* ivar number 1 */
  678.     xladdivar(class,"messages");    /* ivar number 0 */
  679.     xladdmsg(class,"new",mnew);
  680.     xladdmsg(class,"answer",answer);
  681.     xladdmsg(class,"ivars",mivars);
  682.     xladdmsg(class,"cvars",mcvars);
  683.     xladdmsg(class,"isnew",misnew);
  684.  
  685.     /* finish initializing 'object' */
  686.     xladdmsg(object,"class",getclass);
  687.     xladdmsg(object,"show",obshow);
  688.     xladdmsg(object,"isnew",defisnew);
  689.     xladdmsg(object,"sendsuper",sendsuper);
  690. }
  691.